home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue57 / DragDrop / DragImage2U.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-03-23  |  4.7 KB  |  180 lines
  1. unit DragImage2U;
  2.  
  3. {$ifdef Ver90} { Delphi 2.0x }
  4.   {$define DelphiLessThan4}
  5. {$endif}
  6. {$ifdef Ver93} { C++ Builder 1.0x }
  7.   {$define DelphiLessThan4}
  8. {$endif}
  9. {$ifdef Ver100} { Delphi 3.0x }
  10.   {$define DelphiLessThan4}
  11. {$endif}
  12. {$ifdef Ver110} { C++ Builder 3.0x }
  13.   {$define DelphiLessThan4}
  14. {$endif}
  15.  
  16. {$ifndef DelphiLessThan4}
  17.   'This project is designed for Delphi 2 and 3'
  18. {$endif}
  19.  
  20. interface
  21.  
  22. uses
  23.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  24.   StdCtrls, ExtCtrls;
  25.  
  26. type
  27.   //Custom drag object based on TDragObject 
  28.   //in order to work well in Delphi 2 and 3
  29.   TTextDragObject = class(TDragObject)
  30.   private
  31.     FControl: TControl;
  32.     FDragImages: TImageList;
  33.   protected
  34.     function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override;
  35.     function GetDragImages: TCustomImageList; override;
  36.   public
  37.     Data: String;
  38.     constructor Create(Control: TControl);
  39.     destructor Destroy; override;
  40.     property Control: TControl read FControl;
  41.   end;
  42.  
  43.   TForm1 = class(TForm)
  44.     Panel1: TPanel;
  45.     ListBox1: TListBox;
  46.     Label1: TLabel;
  47.     procedure FormCreate(Sender: TObject);
  48.     procedure Label1StartDrag(Sender: TObject; var DragObject: TDragObject);
  49.     procedure ListBox1StartDrag(Sender: TObject;
  50.       var DragObject: TDragObject);
  51.     procedure SharedEndDrag(Sender, Target: TObject; X, Y: Integer);
  52.     procedure Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
  53.       State: TDragState; var Accept: Boolean);
  54.     procedure Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
  55.   private
  56.     FDragObject: TTextDragObject;
  57.   end;
  58.  
  59. var
  60.   Form1: TForm1;
  61.  
  62. const
  63.   crPacMan = 1; { Use values bigger than 0 }
  64.  
  65. implementation
  66.  
  67. {$R *.DFM}
  68.  
  69. {$R PacCur32.Res}
  70.  
  71. { TTextDragObject }
  72.  
  73. constructor TTextDragObject.Create(Control: TControl);
  74. begin
  75.   inherited Create;
  76.   FControl := Control
  77. end;
  78.  
  79. destructor TTextDragObject.Destroy;
  80. begin
  81.   FDragImages.Free;
  82.   inherited;
  83. end;
  84.  
  85. function TTextDragObject.GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor;
  86. begin
  87.   if Accepted then
  88.     Result := crPacMan
  89.   else
  90.     Result := inherited GetDragCursor(Accepted, X, Y)
  91. end;
  92.  
  93. function TTextDragObject.GetDragImages: TCustomImageList;
  94. var
  95.   Bmp: TBitmap;
  96.   Txt: String;
  97. begin
  98.   if not Assigned(FDragImages) then
  99.     FDragImages := TImageList.Create(nil);
  100.   FDragImages.Clear;
  101.   Bmp := TBitmap.Create;
  102.   try
  103.     //Make up some string to write on bitmap
  104.     Txt := Format('      The control called %s says "%s" at %s',
  105.       [Control.Name, Data, FormatDateTime('h:nn am/pm', Time)]);
  106.     Bmp.Canvas.Font.Name := 'Arial';
  107.     Bmp.Canvas.Font.Style := Bmp.Canvas.Font.Style + [fsItalic];
  108.     Bmp.Height := Bmp.Canvas.TextHeight(Txt);
  109.     Bmp.Width := Bmp.Canvas.TextWidth(Txt);
  110.     //Fill background with olive
  111.     Bmp.Canvas.Brush.Color := clOlive;
  112.     Bmp.Canvas.FloodFill(0, 0, clWhite, fsSurface);
  113.     //Write a string on bitmap
  114.     Bmp.Canvas.TextOut(0, 0, Txt);
  115.     FDragImages.Width := Bmp.Width;
  116.     FDragImages.Height := Bmp.Height;
  117.     //Make olive pixels transparent, whilst adding bmp to list
  118.     FDragImages.AddMasked(Bmp, clOlive);
  119.     Result := FDragImages;
  120.   finally
  121.     Bmp.Free;
  122.   end
  123. end;
  124.  
  125. { TForm1 }
  126.  
  127. procedure FixControlStyles(Parent: TControl);
  128. var
  129.   I: Integer;
  130. begin
  131.   Parent.ControlStyle := Parent.ControlStyle + [csDisplayDragImage];
  132.   if Parent is TWinControl then
  133.     with TWinControl(Parent) do
  134.       for I := 0 to ControlCount - 1 do
  135.         FixControlStyles(Controls[I]);
  136. end;
  137.  
  138. procedure TForm1.FormCreate(Sender: TObject);
  139. begin
  140.   Screen.Cursors[crPacMan] := LoadCursor(HInstance, 'PacMan');
  141.   FixControlStyles(Self)
  142. end;
  143.  
  144. procedure TForm1.Label1StartDrag(Sender: TObject;
  145.   var DragObject: TDragObject);
  146. begin
  147.   FDragObject := TTextDragObject.Create(Sender as TLabel);
  148.   FDragObject.Data := TLabel(Sender).Caption;
  149.   DragObject := FDragObject;
  150. end;
  151.  
  152. procedure TForm1.ListBox1StartDrag(Sender: TObject;
  153.   var DragObject: TDragObject);
  154. begin
  155.   FDragObject := TTextDragObject.Create(Sender as TListBox);
  156.   with TListBox(Sender) do
  157.     FDragObject.Data := Items[ItemIndex];
  158.   DragObject := FDragObject;
  159. end;
  160.  
  161. procedure TForm1.SharedEndDrag(Sender, Target: TObject; X, Y: Integer);
  162. begin
  163.   //All draggable controls share this event handler
  164.   FDragObject.Free;
  165.   FDragObject := nil
  166. end;
  167.  
  168. procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
  169.   State: TDragState; var Accept: Boolean);
  170. begin
  171.   Accept := Source is TTextDragObject
  172. end;
  173.  
  174. procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
  175. begin
  176.   (Sender as TPanel).Caption := TTextDragObject(Source).Data
  177. end;
  178.  
  179. end.
  180.